home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d12 / v10n05.arc / CALDEMO.PRG < prev    next >
Text File  |  1991-02-13  |  7KB  |  224 lines
  1. ***********************************************************************
  2. * CALDEMO.PRG
  3. * Demonstrate usage of PopDate
  4. ***********************************************************************
  5. SET ECHO OFF
  6. SET TALK OFF
  7. SET SYSMENU OFF
  8.  
  9. DO BackDrop                          && Background for demo purposes
  10. DO Inquiry                           && Sample date field usage with
  11.                                      && pop-up calendar
  12. RELEASE ALL
  13. CLEAR ALL
  14. RETURN
  15.  
  16. ***********************************************************************
  17. * PROCEDURE Inquiry
  18. * Demonstrate use of PopDate, which is called from PopCal
  19. ***********************************************************************
  20. PROCEDURE Inquiry
  21. DEFINE WINDOW Inquiry FROM  5,13 TO 15,67 ;
  22. COLOR G+/B,N/W,BG+/B TITLE 'Inquiry'
  23. ACTIVATE WINDOW Inquiry
  24.  
  25. @ 1, 8 SAY "Destination:"
  26. @ 3, 2 SAY "Date of Departure:"
  27. @ 4, 5 SAY "Date of Return:"
  28. @ 6, 5 SAY "Number of days:"
  29.  
  30. STORE SPACE(25) TO m->dest
  31. STORE DATE() TO m->depdate
  32. STORE DATE()+1 TO m->retdate
  33.  
  34. ON KEY LABEL F2 DO PopCal            && F2 activates PopCal
  35.  
  36. DO WHILE .T.
  37.    SET COLOR TO ,N/W
  38.    @ 1,21 GET m->dest PICTURE "@M Hawaii, Florida, Italy" ;
  39.    MESSAGE WinMsg("Enter destination, press spacebar to cycle choices")
  40.  
  41.    @ 3,21 GET m->depdate ;
  42.    MESSAGE WinMsg("Enter Departure date, press F2 for calendar") ;
  43.    VALID DateCheck(1, m->depdate, m->retdate) ;
  44.    ERROR "Invalid departure date, please reenter"
  45.  
  46.    @ 4,21 GET m->retdate ;
  47.    MESSAGE WinMsg("Enter Return date, press F2 for calendar") ;
  48.    VALID DateCheck(2, m->depdate, m->retdate) ;
  49.    ERROR "Invalid return date, please reenter"
  50.  
  51.    READ
  52.    SET COLOR TO G+/B
  53.    @ 6,21 SAY (m->retdate - m->depdate)+1 PICTURE [999]
  54.    IF READKEY()==268 .OR. READKEY()==12   && Escape cancels
  55.       EXIT
  56.    ENDIF
  57. ENDDO
  58.  
  59. ON KEY LABEL F2                      && Restore F2
  60. RELEASE WINDOW Inquiry
  61. RETURN
  62.  
  63. ******************************************************************
  64. * PROCEDURE PopCal
  65. *
  66. * Calls POPDATE.  Only allows pop-up if user is currently
  67. * editing the departure date or return date fields
  68. ******************************************************************
  69. PROCEDURE POPCAL
  70. PRIVATE var
  71. var = VARREAD()                      && Find out what field we're in
  72. DO CASE
  73.  CASE var == "DEPDATE" .OR. ;
  74.    var == "RETDATE"                  && If it is the departure date
  75.                                      && or return date fields
  76.    IF EMPTY(&var)                    && If it is empty don't set
  77.       &var = POPDATE(2,51)           && the default in the calendar
  78.    ELSE                              && otherwise pop-up the calendar
  79.       &var = POPDATE(2,51,&var)      && with that date highlighted
  80.    ENDIF
  81.  OTHERWISE
  82. ENDCASE
  83. RETURN
  84.  
  85. *******************************************************************
  86. * FUNCTION WinMsg
  87. *
  88. * Display a centered message on the last line of the active
  89. * window.  For use with the MESSAGE option on @...GET.
  90. *******************************************************************
  91. FUNCTION WinMsg
  92. PARAMETER TEXT
  93. @ WROWS()-1, 0 SAY PADC(TEXT,WCOLS())
  94. RETURN ""
  95.  
  96. *******************************************************************
  97. * FUNCTION DateCheck
  98. * Simple validation for departure and return dates
  99. *******************************************************************
  100. FUNCTION DateCheck
  101. PARAMETERS dnum, ddate, rdate
  102.  
  103. DO CASE
  104.  CASE dnum == 1                      && Validating the departure date
  105.    *
  106.    * --- Can't be before today or empty
  107.    *
  108.    IF ddate < DATE() .OR. EMPTY(ddate)
  109.       RETURN .F.
  110.    ENDIF
  111.  CASE dnum == 2                      && Validating the return date
  112.    *
  113.    * --- Can't be before departure date or empty
  114.    *
  115.    IF rdate < ddate .OR. EMPTY(rdate)
  116.       RETURN .F.
  117.    ENDIF
  118.  OTHERWISE
  119. ENDCASE
  120. RETURN .T.
  121.  
  122. ***********************************************************************
  123. * PROCEDURE BackDrop
  124. * Put some background on the screen for demo purposes
  125. ***********************************************************************
  126. PROCEDURE BackDrop
  127. DEFINE WINDOW BackDrop FROM  3, 1 TO 17,79 ;
  128. COLOR G+/B,N/W,BG+/B TITLE 'XYZ Travel Agency'
  129. ACTIVATE WINDOW BackDrop
  130. @ 1, 3 SAY "Prefix: Mr. and Mrs."
  131. @ 2, 5 SAY "Last: Doe"
  132. @ 3, 4 SAY "First: John"
  133. @ 4, 3 SAY "Middle: J."
  134. @ 5, 3 SAY "Suffix: Sr."
  135. @ 7, 2 SAY "Address: 27 Pine Lane"
  136. @ 8, 9 SAY ": Suite 21A"
  137. @ 9, 9 SAY ":"
  138. @10, 5 SAY "City: Anytown"
  139. @11, 4 SAY "State: PA  Zip: 12345"
  140. RETURN
  141.  
  142. ***********************************************************************
  143. *   Name: POPDATE.PRG
  144. * Author: Andrew Coupe
  145. *  Usage: <expD>=POPDATE(<row>,<col>,[<default>])
  146. *  Notes: UDF to popup a date selection box in FoxPRO 1.02
  147. ***********************************************************************
  148. FUNCTION POPDATE
  149. PARAMETER row,col,DEFAULT
  150.  
  151. thismsg = SET("MESSAGE",1)            && Record current message line
  152. thisdate =_diarydate                  && Save original date
  153. *
  154. * --- If default date is passed, use it, else use _dairydate
  155. *
  156. DEFAULT = IIF( PARAMETERS()=3, DEFAULT, _diarydate)
  157. _diarydate = DEFAULT
  158.  
  159. DEFINE WINDOW CAL FROM row,col TO row+16,col+22 ;
  160. DOUBLE TITLE "[CALENDAR]"
  161. *
  162. * --- Need SET STATUS ON to see the following message
  163. *
  164. SET MESSAGE TO ;
  165. "Change date with arrow keys. [T]oday, Month:[PgUp/PgDn] Year:[^PgUp/^PgDn]"
  166.  
  167. ACTIVATE WINDOW cal
  168.  
  169. ACTIVATE WINDOW calendar IN cal
  170.  
  171. MOVE WINDOW calendar TO -1,-1        && Center calendar in window
  172.  
  173. DO WHILE LASTKEY() # 27              && While ESCAPE not HIT
  174.  
  175.    i=INKEY(0,"H")                    && Get keystroke
  176.  
  177.    DO CASE
  178.     CASE i=13 .OR. i==27             && Enter or Esc
  179.       EXIT
  180.  
  181.     CASE i=84.OR. i=116              && 'T' for Today
  182.       _diarydate=DATE()
  183.  
  184.     CASE i =24                       && Down arrow
  185.       _diarydate=_diarydate+7
  186.  
  187.     CASE i= 5                        && Up arrow
  188.       _diarydate=_diarydate-7
  189.  
  190.     CASE i=19                        && Left arrow
  191.       _diarydate=_diarydate-1
  192.  
  193.     CASE i=4                         && Right arrow
  194.       _diarydate=_diarydate+1
  195.  
  196.     CASE i=3                         && Page down
  197.       _diarydate=gomonth(_diarydate,1)
  198.  
  199.     CASE i=18                        && Page up
  200.       _diarydate=gomonth(_diarydate,-1)
  201.  
  202.     CASE I= 30                       && ^Page down
  203.       _diarydate=gomonth(_diarydate,12)
  204.  
  205.     CASE I= 31                       && ^Page Up
  206.       _diarydate=gomonth(_diarydate,-12)
  207.    ENDCASE
  208. ENDDO
  209.  
  210. SET MESSAGE TO (thismsg)             && Restore message
  211. RELEASE WINDOWS cal                  && Release CAL windows
  212. *
  213. * --- Return default date in ESC was pressed
  214. *     otherwise return the selected date
  215. *
  216. newdate = ;
  217. IIF( LASTKEY()=27, default, _diarydate)
  218.  
  219. _diarydate = thisdate                && Set system variable back
  220.  
  221. RETURN newdate                       && Return the selected date
  222.  
  223.  
  224.